C
C  This file is part of MUMPS 5.6.2, released
C  on Wed Oct 11 09:36:25 UTC 2023
C
C
C  Copyright 1991-2023 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  Mumps Technologies, University of Bordeaux.
C
C  This version of MUMPS is provided to you free of charge. It is
C  released under the CeCILL-C license 
C  (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
C  https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
C
      SUBROUTINE ZMUMPS_PROCESS_DESC_BANDE( MYID, BUFR, LBUFR, 
     &     LBUFR_BYTES,
     &     IWPOS, IWPOSCB,
     &     IPTRLU, LRLU, LRLUS,
     &     N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD,
     &     PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP,
     &     KEEP,KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2,
#if ! defined(NO_FDM_DESCBAND)
     &     IWHANDLER_IN,
#endif
     &     IFLAG, IERROR )
      USE ZMUMPS_LOAD
      USE ZMUMPS_LR_DATA_M, ONLY: ZMUMPS_BLR_INIT_FRONT,
     &                            ZMUMPS_BLR_SAVE_NFS4FATHER
#if ! defined(NO_FDM_DESCBAND)
      USE MUMPS_FAC_DESCBAND_DATA_M
#endif
      IMPLICIT NONE
      INTEGER MYID
      INTEGER KEEP(500)
      INTEGER(8) KEEP8(150)
      DOUBLE PRECISION DKEEP(230)
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER BUFR( LBUFR )
      INTEGER(8) :: IPTRLU, LRLU, LRLUS, LA
      INTEGER IWPOS, IWPOSCB, N, LIW
      INTEGER IW( LIW )
      COMPLEX(kind=8) A( LA )
      INTEGER, INTENT(IN) :: SLAVEF
      INTEGER, INTENT(IN) :: PROCNODE_STEPS(KEEP(28)), DAD(KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER(8) :: PTRAST(KEEP(28))
      INTEGER PTRIST(KEEP(28)), STEP(N), 
     & PIMASTER(KEEP(28)), 
     & ITLOC( N + KEEP(253) )
      COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
      INTEGER :: ISTEP_TO_INIV2(KEEP(71))
#if ! defined(NO_FDM_DESCBAND)
      INTEGER IWHANDLER_IN
#endif
      INTEGER COMP, IFLAG, IERROR
      INTEGER INODE, NBPROCFILS, NCOL, NROW, NASS, NSLAVES
      INTEGER NSLAVES_HDR, NFRONT
      INTEGER LREQ
      INTEGER :: IBUFR
      INTEGER(8) :: LREQCB
#if ! defined(NO_FDM_DESCBAND)
      INTEGER :: IWHANDLER_LOC
#endif
      DOUBLE PRECISION FLOP1
      INCLUDE 'mumps_headers.h'
#if ! defined(NO_FDM_DESCBAND)
      INTEGER :: INFO_TMP(2)
#else
#endif
      INTEGER :: LRSTATUS
      INTEGER :: ESTIM_NFS4FATHER_ATSON
      LOGICAL :: LR_ACTIVATED, COMPRESS_CB
      COMPLEX(kind=8), POINTER, DIMENSION(:) :: DYNAMIC_CB
      INTEGER(8) :: TMP_ADDRESS
      INTEGER :: allocok
      INODE = BUFR( 2 )
      NBPROCFILS = BUFR( 3 )
      NROW        = BUFR( 4 )
      NCOL        = BUFR( 5 )
      NASS        = BUFR( 6 )
      NFRONT      = BUFR( 7 )
      NSLAVES_HDR = BUFR( 8 )
      NSLAVES     = BUFR( 9 )
      LRSTATUS    = BUFR(10 )
      ESTIM_NFS4FATHER_ATSON = BUFR(11)
      IBUFR    = 12
#if ! defined(NO_FDM_DESCBAND)
      IWHANDLER_LOC = IWHANDLER_IN
      IF ((IWHANDLER_IN .LE. 0) .AND.
     &   (INODE .NE. INODE_WAITED_FOR)) THEN
        INFO_TMP=0
        CALL MUMPS_FDBD_SAVE_DESCBAND(INODE, BUFR(1), BUFR,
     &                                IWHANDLER_LOC, INFO_TMP)
        IF (INFO_TMP(1) < 0) THEN
          IFLAG = INFO_TMP(1)
          IERROR = INFO_TMP(2)
          RETURN
        ENDIF
        GOTO 555
      ENDIF
#endif
      IF ( KEEP(50) .eq. 0 ) THEN
         FLOP1 = dble( NASS * NROW ) +
     &     dble(NROW*NASS)*dble(2*NCOL-NASS-1)
      ELSE
         FLOP1 = dble( NASS ) * dble( NROW )
     &            * dble( 2 * NCOL - NROW - NASS + 1)
      END IF
      CALL ZMUMPS_LOAD_UPDATE(1,.TRUE.,FLOP1, KEEP,KEEP8)
      IF ( KEEP(50) .eq. 0 ) THEN
        NSLAVES = NSLAVES_HDR + XTRA_SLAVES_UNSYM
      ELSE
        NSLAVES = NSLAVES_HDR + XTRA_SLAVES_SYM   
      END IF
      LREQ   = NROW + NCOL + 6 + NSLAVES + KEEP(IXSZ)
      LREQCB = int(NCOL,8) * int(NROW,8)
      IF ( LREQCB .GT. LRLUS .AND. KEEP(101) .EQ. 0 .AND.
     &     KEEP8(73) + LREQCB .LE. KEEP8(75) ) THEN
        CALL ZMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE.,
     &       MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA,
     &       LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD,
     &       PTRIST,PTRAST, STEP, PIMASTER,PAMASTER,
     &       LREQ, 0_8, 
     &       INODE, S_ACTIVE, .TRUE.,
     &       COMP, LRLUS, KEEP8(67), IFLAG, IERROR
     &     )
        IF ( IFLAG .LT. 0 ) RETURN
#if defined(MUMPS_ALLOC_FROM_C)
        CALL MUMPS_MALLOC_C( TMP_ADDRESS,
     &      LREQCB * int(KEEP(35),8) )
        IF (TMP_ADDRESS .EQ. 0_8) THEN
          allocok=1 
        ELSE 
          allocok=0
        ENDIF
#else
        ALLOCATE(DYNAMIC_CB(LREQCB), stat=allocok)
#endif
        IF (allocok .GT. 0) THEN
          CALL ZMUMPS_FREE_BLOCK_CB_STATIC( .FALSE., MYID, N,
     &    IWPOSCB + 1, IW, LIW, LRLU, LRLUS, IPTRLU, IWPOSCB,
     &    LA, KEEP, KEEP8, .FALSE. )
        ELSE
          CALL MUMPS_DM_FAC_UPD_DYN_MEMCNTS( LREQCB,
     &    KEEP(405).EQ.1, 
     &    KEEP8, IFLAG, IERROR,
     &    .TRUE., 
     &    .FALSE. ) 
#if ! defined(MUMPS_ALLOC_FROM_C)
          CALL MUMPS_ADDR_C( DYNAMIC_CB(1), TMP_ADDRESS )
#endif
          CALL MUMPS_STOREI8(LREQCB, IW(IWPOSCB+1+XXD))
          PTRIST(STEP(INODE)) = IWPOSCB + 1
          PTRAST(STEP(INODE)) = TMP_ADDRESS
        ENDIF
      ENDIF
      IF ( PTRIST(STEP(INODE)) .EQ. 0 ) THEN
        CALL ZMUMPS_ALLOC_CB(.FALSE., 0_8, .FALSE.,.TRUE.,
     &     MYID,N, KEEP, KEEP8, DKEEP, IW, LIW, A, LA,
     &     LRLU, IPTRLU,IWPOS,IWPOSCB, SLAVEF, PROCNODE_STEPS, DAD,
     &     PTRIST,PTRAST, STEP, PIMASTER,PAMASTER,
     &     LREQ, LREQCB, INODE, S_ACTIVE, .TRUE.,
     &     COMP, LRLUS, KEEP8(67), IFLAG, IERROR
     &     )
        IF ( IFLAG .LT. 0 ) RETURN
        PTRIST(STEP(INODE)) = IWPOSCB + 1
        PTRAST(STEP(INODE)) = IPTRLU  + 1_8
      ENDIF
#     if ! defined(NO_FDM_DESCBAND)
 555  CONTINUE
#     endif
#     if ! defined(NO_FDM_DESCBAND)
        IF ((IWHANDLER_IN .LE. 0) .AND.
     &     (INODE .NE. INODE_WAITED_FOR)) THEN
          RETURN
        ENDIF
        IW(IWPOSCB+1+XXA) = IWHANDLER_LOC
#     endif
        IW(IWPOSCB+1+XXF) = -9999
      IW( IWPOSCB + 1+KEEP(IXSZ) ) = NCOL
      IW( IWPOSCB + 2+KEEP(IXSZ) ) = - NASS
      IW( IWPOSCB + 3+KEEP(IXSZ) ) = NROW
      IW( IWPOSCB + 4+KEEP(IXSZ) ) = 0
      IW( IWPOSCB + 5+KEEP(IXSZ) ) = NASS
      IW( IWPOSCB + 6+KEEP(IXSZ) ) = NSLAVES
      IW( IWPOSCB + 7+KEEP(IXSZ)+NSLAVES : 
     &           IWPOSCB + 6+KEEP(IXSZ)+NSLAVES + NROW + NCOL )
     &= BUFR( IBUFR + NSLAVES_HDR :
     &        IBUFR + NSLAVES_HDR + NROW + NCOL - 1 )
      IF ( KEEP(50) .eq. 0 ) THEN
        IW( IWPOSCB + 7+KEEP(IXSZ) ) = S_ROOTBAND_INIT
        IF (NSLAVES_HDR.GT.0) THEN
          write(6,*) " Internal error in ZMUMPS_PROCESS_DESC_BANDE "
          CALL MUMPS_ABORT()
        ENDIF
      ELSE
        IW( IWPOSCB+7+KEEP(IXSZ) ) = huge(IW(IWPOSCB+7+KEEP(IXSZ)))
        IW( IWPOSCB + 8+KEEP(IXSZ) ) = NFRONT
        IW( IWPOSCB + 9+KEEP(IXSZ) ) = S_ROOTBAND_INIT
        IW( IWPOSCB + 7+XTRA_SLAVES_SYM+KEEP(IXSZ):
     &      IWPOSCB + 6+XTRA_SLAVES_SYM+KEEP(IXSZ)+NSLAVES_HDR ) =
     &       BUFR( IBUFR: IBUFR - 1 + NSLAVES_HDR )
      END IF
      IW(IWPOSCB+1+XXNBPR)=NBPROCFILS
      IW(IWPOSCB+1+XXLR)=LRSTATUS
      COMPRESS_CB    = ((LRSTATUS.EQ.1).OR.
     &                  (LRSTATUS.EQ.3))
      LR_ACTIVATED   = (LRSTATUS.GT.0)
      IF (LR_ACTIVATED.AND.
     &       (KEEP(480).NE.0
     &       .OR.
     &       (
     &         (KEEP(486).EQ.2) 
     &       )
     &       .OR.COMPRESS_CB
     &       )) THEN
         INFO_TMP=0
         CALL ZMUMPS_BLR_INIT_FRONT (IW(IWPOSCB+1+XXF), INFO_TMP) 
         IF (INFO_TMP(1).LT.0)  THEN
          IFLAG = INFO_TMP(1)
          IERROR = INFO_TMP(2)
          RETURN
         ENDIF
         IF (COMPRESS_CB.AND.
     &     (KEEP(219).NE.0).AND.(KEEP(50).EQ.2).AND.
     &     (ESTIM_NFS4FATHER_ATSON.GE.0)
     &    ) THEN
            CALL ZMUMPS_BLR_SAVE_NFS4FATHER ( IW(IWPOSCB+1+XXF),
     &             ESTIM_NFS4FATHER_ATSON )
         ENDIF
      ENDIF
      IF (NBPROCFILS .EQ. 0) THEN
      ENDIF
      RETURN
      END SUBROUTINE ZMUMPS_PROCESS_DESC_BANDE
      RECURSIVE SUBROUTINE ZMUMPS_TREAT_DESCBAND( INODE,
     &    COMM_LOAD, ASS_IRECV,
     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     &    IWPOS, IWPOSCB, IPTRLU,
     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     &    PTLUST, PTRFAC,
     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     &    IFLAG, IERROR, COMM, PERM,
     &    IPOOL, LPOOL, LEAF, NBFIN, MYID, SLAVEF,
     &
     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW,
     &    PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR,
     &    INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE,
     &    LPTRAR, NELT, FRTPTR, FRTELT,
     &
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE,
     &    STACK_RIGHT_AUTHORIZED
     &    , LRGROUPS
     & )
#     if ! defined(NO_FDM_DESCBAND)
      USE MUMPS_FAC_DESCBAND_DATA_M
#     endif
      USE ZMUMPS_STRUC_DEF, ONLY : ZMUMPS_ROOT_STRUC
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: INODE  
      TYPE (ZMUMPS_ROOT_STRUC) :: root
      INTEGER KEEP(500), ICNTL(60)
      INTEGER(8) KEEP8(150)
      DOUBLE PRECISION       DKEEP(230)
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER COMM_LOAD, ASS_IRECV
      INTEGER BUFR( LBUFR )
      INTEGER(8) :: LA, POSFAC, IPTRLU, LRLU, LRLUS
      INTEGER IWPOS, IWPOSCB
      INTEGER N, LIW
      INTEGER IW( LIW )
      COMPLEX(kind=8) A( LA )
      INTEGER, intent(in) :: LRGROUPS(KEEP(280))
      INTEGER(8) :: PTRAST(KEEP(28))
      INTEGER(8) :: PTRFAC(KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER PTRIST( KEEP(28) ),
     &        PTLUST(KEEP(28))
      INTEGER STEP(N),
     & PIMASTER(KEEP(28))
      INTEGER COMP
      INTEGER NSTK_S(KEEP(28)), PROCNODE_STEPS( KEEP(28) )
      INTEGER PERM(N)
      INTEGER IFLAG, IERROR, COMM
      INTEGER LPOOL, LEAF
      INTEGER IPOOL( LPOOL )
      INTEGER MYID, SLAVEF, NBFIN
      DOUBLE PRECISION OPASSW, OPELIW
      INTEGER NELT, LPTRAR
      INTEGER FRTPTR( N+1 ), FRTELT( NELT )
      INTEGER ITLOC( N + KEEP(253) ), FILS( N ), DAD( KEEP(28) )
      COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
      INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR )
      INTEGER(8), INTENT(IN) :: PTR8ARR(KEEP(193))
      INTEGER, INTENT(IN) :: NINCOLARR(KEEP(194))
      INTEGER, INTENT(IN) :: NINROWARR(KEEP(195))
      INTEGER, INTENT(IN) :: PTRDEBARR(KEEP(196))
      INTEGER ND( KEEP(28) ), FRERE( KEEP(28) )
      INTEGER ISTEP_TO_INIV2(KEEP(71)),
     &        TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56)))
      COMPLEX(kind=8) DBLARR( KEEP8(26) )
      INTEGER INTARR( KEEP8(27) )
      LOGICAL, intent(in) :: STACK_RIGHT_AUTHORIZED
      INCLUDE 'mpif.h'
      INCLUDE 'mumps_tags.h'
      INCLUDE 'mumps_headers.h'
      LOGICAL :: BLOCKING, SET_IRECV, MESSAGE_RECEIVED
      INTEGER :: STATUS(MPI_STATUS_SIZE)
      INTEGER :: SRC_DESCBAND
#if ! defined(NO_FDM_DESCBAND)
      INTEGER :: IWHANDLER
      TYPE(DESCBAND_STRUC_T), POINTER :: DESCBAND_STRUC
#endif
      INTEGER MUMPS_PROCNODE
      EXTERNAL MUMPS_PROCNODE
      SRC_DESCBAND = MUMPS_PROCNODE( PROCNODE_STEPS(STEP(INODE)),
     &           KEEP(199) )
#     if ! defined(NO_FDM_DESCBAND)
      IF (MUMPS_FDBD_IS_DESCBAND_STORED( INODE, IWHANDLER )) THEN 
        CALL MUMPS_FDBD_RETRIEVE_DESCBAND(IWHANDLER, DESCBAND_STRUC)
        CALL ZMUMPS_PROCESS_DESC_BANDE( MYID, DESCBAND_STRUC%BUFR(1),
     &       DESCBAND_STRUC%LBUFR,
     &       LBUFR_BYTES,
     &       IWPOS, IWPOSCB,
     &       IPTRLU, LRLU, LRLUS,
     &       N, IW, LIW, A, LA, SLAVEF, PROCNODE_STEPS, DAD,
     &       PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, COMP,
     &       KEEP, KEEP8, DKEEP, ITLOC, RHS_MUMPS, ISTEP_TO_INIV2,
     &       IWHANDLER,
     &       IFLAG, IERROR )
        IF (IFLAG .LT. 0) GOTO 500 
        CALL MUMPS_FDBD_FREE_DESCBAND_STRUC(IW(PTRIST(STEP(INODE))+XXA))
      ELSE 
         IF (INODE_WAITED_FOR.GT.0) THEN
          WRITE(*,*) " Internal error 1 in ZMUMPS_TREAT_DESCBAND",
     &    INODE, INODE_WAITED_FOR
          CALL MUMPS_ABORT()
        ENDIF
        INODE_WAITED_FOR = INODE
#     endif
      DO WHILE (PTRIST(STEP(INODE)) .EQ. 0)
        BLOCKING = .TRUE.
        SET_IRECV = .FALSE.
        MESSAGE_RECEIVED = .FALSE.
        CALL ZMUMPS_TRY_RECVTREAT(COMM_LOAD,
     &    ASS_IRECV, BLOCKING, SET_IRECV, MESSAGE_RECEIVED,
     &    SRC_DESCBAND, MAITRE_DESC_BANDE,
     &    STATUS, 
     &    BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC,
     &    IWPOS, IWPOSCB, IPTRLU,
     &    LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST,
     &    PTLUST, PTRFAC,
     &    PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP,
     &    IFLAG, IERROR, COMM,
     &    PERM, IPOOL, LPOOL, LEAF,
     &    NBFIN, MYID, SLAVEF,
     &    root, OPASSW, OPELIW, ITLOC, RHS_MUMPS,
     &    FILS, DAD, PTRARW, PTRAIW,
     &    PTR8ARR, NINCOLARR, NINROWARR, PTRDEBARR,
     &    INTARR, DBLARR, ICNTL, KEEP,KEEP8,DKEEP, ND, FRERE,
     &    LPTRAR, NELT, FRTPTR, FRTELT, 
     &    ISTEP_TO_INIV2, TAB_POS_IN_PERE, .TRUE. 
     &    , LRGROUPS
     &    )
        IF (IFLAG .LT. 0) THEN
          RETURN
        ENDIF
      ENDDO
#     if ! defined(NO_FDM_DESCBAND)
        INODE_WAITED_FOR = -1
      ENDIF
#     endif
      RETURN
 500  CONTINUE
      CALL ZMUMPS_BDC_ERROR( MYID, SLAVEF, COMM, KEEP )
      RETURN
      END SUBROUTINE ZMUMPS_TREAT_DESCBAND
